home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / STklos / Tk / Tk-meta.stklos < prev    next >
Encoding:
Text File  |  1996-04-27  |  6.8 KB  |  197 lines
  1. ;;;;
  2. ;;;; T k - m e t a . s t k         --  Metaclasses definitions
  3. ;;;;
  4. ;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  15. ;;;;    Creation date: 24-Feb-1994 15:08
  16. ;;;; Last file update: 23-Aug-1995 11:59
  17. ;;;;
  18. ;;;;
  19. ;;;; The <With-Tk-virtual-slots-metaclass> original idea and implementation 
  20. ;;;; are due to Robert DeLine <deline@amarillo.pa.dec.com>.
  21. ;;;;
  22. ;;;;
  23. ;;;; Compatibility:
  24. ;;;;     - the :pseudo allocation is now replaced by :tk-virtual (Rob DeLine
  25. ;;;;      proposition). However both name are accepted. Avoid to use :pseudo
  26. ;;;;      since it will disappear in the future.
  27. ;;;;
  28. ;;;;    - the :special allocation is now replaced by :propagated (Rob DeLine
  29. ;;;;      proposition). However both name are accepted. Avoid to use :special
  30. ;;;;      since it will disappear in the future.
  31. ;;;;
  32. ;;;;    - the :propagate option for propagated slots is now replaced by 
  33. ;;;;      :propagate-to. Avoid to use :propagate since it will disappear in
  34. ;;;;      the future.
  35.  
  36. (require "stklos")
  37.  
  38. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39. ;;;;
  40. ;;;; <With-Tk-virtual-slots-metaclass> class
  41. ;;;;
  42. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43. ;;
  44. ;; Define Tk slots getters and setters. In fact this metaclass permits 
  45. ;; a direct mapping of STklos slots to the Tk-library widget options.
  46. ;; For instance, a <Label> has a slot called "text". Accessing this slot
  47. ;; will call a Tk (C) library function 
  48. ;;     (xxxx 'cget 'text)        for reading
  49. ;; or
  50. ;;     (xxxx 'configure 'text value)    for writing
  51. ;; where xxxx is an internal name generated during instance creation).
  52. (define-class <With-Tk-virtual-slots-metaclass> (<class>)
  53.   (tk-valid-options))
  54.  
  55.  
  56. (define-method initialize ((class <With-Tk-virtual-slots-metaclass>) initargs)
  57.   (next-method)
  58.   ;; Build a A-list of allowed keywords. The A-list key is a scheme init
  59.   ;; keyword and the data is the tk option name for this keyword.
  60.   ;; Those keywords will be passed to the Tk-command at build time
  61.   (let ((slots   (slot-ref class 'slots))
  62.     (res     '())
  63.     (tk-virtual? (lambda(s) 
  64.                (memv (get-slot-allocation s) '(:tk-virtual :pseudo)))))
  65.  
  66.     (for-each (lambda (s)
  67.         (when (tk-virtual? s) 
  68.               (let* ((key     (make-keyword (car s)))
  69.                  (tk-name (get-keyword :tk-name (cdr s) (car s))))
  70.             (set! res (cons (vector key (make-keyword tk-name) (car s))
  71.                     res)))))
  72.           slots)
  73.     
  74.     ;; Store all this list in the new allocated class
  75.     (slot-set! class 'tk-valid-options res)))
  76.  
  77.  
  78. (define-method make-instance ((class <With-Tk-virtual-slots-metaclass>) initargs)
  79.   (letrec ((instance   (allocate-instance class initargs))
  80.        (valids     (slot-ref class 'tk-valid-options))
  81.        (find       (lambda (key l)
  82.              (cond
  83.               ((null? l) #f)
  84.               ((eq? key (vector-ref (car l) 0)) (car l))
  85.               (else     (find key (cdr l))))))
  86.        (tk-options ())
  87.        (other-args ()))
  88.  
  89.     ;; Filter initargs to pass only valid options to TK
  90.     (do ((args initargs (cddr args)))
  91.     ((null? args))
  92.       (let ((opt (find (car args) valids)))
  93.     (if opt
  94.         (set! tk-options (list* (vector-ref opt 1)(cadr args) tk-options))
  95.         (set! other-args (list* (car args) (cadr args) other-args)))))
  96.  
  97.     ;; Now initialize the instance with the two lists of args.
  98.     (initialize instance (append other-args (list :tk-options tk-options)))
  99.     instance))
  100.  
  101. (define-method compute-get-n-set ((class <With-Tk-virtual-slots-metaclass>) slot)
  102.   (if (memv (get-slot-allocation slot) '(:tk-virtual :pseudo))
  103.       [let ((tk-name (make-keyword (get-keyword :tk-name (cdr slot) (car slot)))))
  104.     (compute-tk-virtual-get-n-set class tk-name)]
  105.       [next-method]))
  106.  
  107.  
  108. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  109. ;;;;
  110. ;;;; <Tk-metaclass> metaclass
  111. ;;;;
  112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  113.  
  114. (define-class <Tk-metaclass> (<With-Tk-virtual-slots-metaclass>)
  115.   ())
  116.  
  117. (define-method compute-tk-virtual-get-n-set ((class <Tk-metaclass>) tk-name)
  118.   (list
  119.    (lambda (o)   ((slot-ref o 'Id) 'cget tk-name))
  120.    (lambda (o v) ([slot-ref o 'Id] 'configure tk-name v))))
  121.  
  122.  
  123. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  124. ;;;;
  125. ;;;; <Tk-item-metaclass> metaclass
  126. ;;;;
  127. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  128.  
  129. (define-class <Tk-item-metaclass> (<With-Tk-virtual-slots-metaclass>)
  130.   ())
  131.  
  132. (define-method compute-tk-virtual-get-n-set ((class <Tk-item-metaclass>) tk-name)
  133.   (list
  134.    (lambda (o)
  135.      ((slot-ref o 'Id) 'itemcget (slot-ref o 'Cid) tk-name))
  136.    (lambda (o v)
  137.      ((slot-ref o 'Id) 'itemconf (slot-ref o 'Cid) tk-name v))))
  138.  
  139.  
  140. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  141. ;;;;
  142. ;;;; <Tk-tag-metaclass> metaclass
  143. ;;;;
  144. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  145.  
  146. (define-class <Tk-tag-metaclass> (<With-Tk-virtual-slots-metaclass>)
  147.   ())
  148.  
  149. (define-method compute-tk-virtual-get-n-set ((class <Tk-tag-metaclass>) tk-name)
  150.   (list
  151.    (lambda (o)
  152.      ((slot-ref o 'Id) 'tag 'cget (slot-ref o 'Tid) tk-name))
  153.    (lambda (o v)
  154.      ((slot-ref o 'Id) 'tag 'configure (slot-ref o 'Tid) tk-name v))))
  155.  
  156.  
  157.  
  158. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  159. ;;;;
  160. ;;;; <Tk-text-window-metaclass> metaclass
  161. ;;;;
  162. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  163.  
  164. (define-class <Tk-text-window-metaclass> (<With-Tk-virtual-slots-metaclass>)
  165.   ())
  166.  
  167. (define-method compute-tk-virtual-get-n-set ((class <Tk-text-window-metaclass>) 
  168.                          tk-name)
  169.   (list
  170.    (lambda (o)
  171.      ((slot-ref o 'Id) 'window 'cget (slot-ref o 'index) tk-name))
  172.    (lambda (o v)
  173.      ((slot-ref o 'Id) 'window 'configure (slot-ref o 'index) tk-name v))))
  174.  
  175.  
  176. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  177. ;;;;
  178. ;;;; <Tk-composite-metaclass> metaclass
  179. ;;;;
  180. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  181.  
  182. (define-class <Tk-composite-metaclass> (<Tk-metaclass> <Composite-metaclass>)
  183.   ())
  184.  
  185. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  186. ;;;;
  187. ;;;; <Tk-composite-item-metaclass> metaclass
  188. ;;;;
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190.  
  191. (define-class <Tk-composite-item-metaclass> (<Tk-item-metaclass> 
  192.                          <Composite-metaclass>)
  193.   ()
  194. )
  195.  
  196. (provide "Tk-meta")
  197.